home *** CD-ROM | disk | FTP | other *** search
- /*
- * This is a hack to retain partial compatibility with shared library
- * version 3.0 which was based on tclX7.1a-B5.
- */
-
- /*
- * tkXshell.c
- *
- * Version of Tk main that is modified to build a wish shell with the Extended
- * Tcl command set and libraries. This makes it easier to use a different
- * main.
- *-----------------------------------------------------------------------------
- * Copyright 1991-1993 Karl Lehenbauer and Mark Diekhans.
- *
- * Permission to use, copy, modify, and distribute this software and its
- * documentation for any purpose and without fee is hereby granted, provided
- * that the above copyright notice appear in all copies. Karl Lehenbauer and
- * Mark Diekhans make no representations about the suitability of this
- * software for any purpose. It is provided "as is" without express or
- * implied warranty.
- *-----------------------------------------------------------------------------
- * $Id: tkXshell.c,v 3.0 1993/11/19 07:01:36 markd Rel $
- *-----------------------------------------------------------------------------
- */
-
- /*
- * main.c --
- *
- * This file contains the main program for "wish", a windowing
- * shell based on Tk and Tcl. It also provides a template that
- * can be used as the basis for main programs for other Tk
- * applications.
- *
- * Copyright (c) 1990-1993 The Regents of the University of California.
- * All rights reserved.
- *
- * Permission is hereby granted, without written agreement and without
- * license or royalty fees, to use, copy, modify, and distribute this
- * software and its documentation for any purpose, provided that the
- * above copyright notice and the following two paragraphs appear in
- * all copies of this software.
- *
- * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
- * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
- * OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
- * CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
- *
- * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
- * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
- * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
- * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
- * PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
- */
-
- #ifdef __cplusplus
- # include "tcl++.h"
- # include <unistd.h>
- #else
- # include "tclExtend.h"
- #endif
-
- #include "tk.h"
-
- /*
- * Declarations for various library procedures and variables (don't want
- * to include tkInt.h or tkConfig.h here, because people might copy this
- * file out of the Tk source directory to make their own modified versions).
- */
-
- extern void exit _ANSI_ARGS_((int status));
- extern int isatty _ANSI_ARGS_((int fd));
- extern int read _ANSI_ARGS_((int fd, char *buf, size_t size));
- extern char * strrchr _ANSI_ARGS_((CONST char *string, int c));
-
- /*
- * Global variables used by the main program:
- */
-
- static Tk_Window mainWindow; /* The main window for the application. If
- * NULL then the application no longer
- * exists. */
- static Tcl_Interp *interp; /* Interpreter for this application. */
- extern char *tcl_RcFileName; /* Name of a user-specific startup script
- * to source if the application is being run
- * interactively (e.g. "~/.wishrc"). Set
- * by Tcl_AppInit. NULL means don't source
- * anything ever. */
- static Tcl_DString command; /* Used to assemble lines of terminal input
- * into Tcl commands. */
- static int gotPartial = 0; /* Partial command in buffer. */
- static int tty; /* Non-zero means standard input is a
- * terminal-like device. Zero means it's
- * a file. */
- static char exitCmd[] = "exit";
- static char errorExitCmd[] = "exit 1";
-
- /*
- * Command-line options:
- */
-
- static int synchronize = 0;
- static char *fileName = NULL;
- static char *name = NULL;
- static char *display = NULL;
- static char *geometry = NULL;
-
- static Tk_ArgvInfo argTable[] = {
- {"-file", TK_ARGV_STRING, (char *) NULL, (char *) &fileName,
- "File from which to read commands"},
- {"-geometry", TK_ARGV_STRING, (char *) NULL, (char *) &geometry,
- "Initial geometry for window"},
- {"-display", TK_ARGV_STRING, (char *) NULL, (char *) &display,
- "Display to use"},
- {"-name", TK_ARGV_STRING, (char *) NULL, (char *) &name,
- "Name to use for application"},
- {"-sync", TK_ARGV_CONSTANT, (char *) 1, (char *) &synchronize,
- "Use synchronous mode for display server"},
- {(char *) NULL, TK_ARGV_END, (char *) NULL, (char *) NULL,
- (char *) NULL}
- };
-
- /*
- * Forward declarations for procedures defined later in this file:
- */
-
- static void StdinProc _ANSI_ARGS_((ClientData clientData,
- int mask));
- static void SignalProc _ANSI_ARGS_((int signalNum));
-
- /*
- *----------------------------------------------------------------------
- *
- * TkX_Wish --
- *
- * Main program for Wish.
- *
- * Results:
- * None. This procedure never returns (it exits the process when
- * it's done
- *
- * Side effects:
- * This procedure initializes the wish world and then starts
- * interpreting commands; almost anything could happen, depending
- * on the script being interpreted.
- *
- *----------------------------------------------------------------------
- */
-
- void
- __TkX_Main (argc, argv)
- int argc; /* Number of arguments. */
- char **argv; /* Array of argument strings. */
- {
- char *args, *p, *msg;
- char buf[20];
- int code;
-
- interp = Tcl_CreateInterp();
- #ifdef TCL_MEM_DEBUG
- Tcl_InitMemory(interp);
- #endif
-
- /*
- * Parse command-line arguments.
- */
-
- if (Tk_ParseArgv(interp, (Tk_Window) NULL, &argc, argv, argTable, 0)
- != TCL_OK) {
- fprintf(stderr, "%s\n", interp->result);
- exit(1);
- }
- if (name == NULL) {
- if (fileName != NULL) {
- p = fileName;
- } else {
- p = argv[0];
- }
- name = strrchr(p, '/');
- if (name != NULL) {
- name++;
- } else {
- name = p;
- }
- }
-
- /*
- * If a display was specified, put it into the DISPLAY
- * environment variable so that it will be available for
- * any sub-processes created by us.
- */
-
- if (display != NULL) {
- Tcl_SetVar2(interp, "env", "DISPLAY", display, TCL_GLOBAL_ONLY);
- }
-
- /*
- * Set the "tcl_interactive" variable.
- */
- tty = isatty(0);
- Tcl_SetVar(interp, "tcl_interactive",
- ((fileName == NULL) && tty) ? "1" : "0", TCL_GLOBAL_ONLY);
-
- tty = isatty(0);
-
- /*
- * Initialize the Tk application.
- */
-
- mainWindow = Tk_CreateMainWindow(interp, display, name, "Tk");
- if (mainWindow == NULL) {
- fprintf(stderr, "%s\n", interp->result);
- exit(1);
- }
- Tk_SetClass(mainWindow, "Tk");
- if (synchronize) {
- XSynchronize(Tk_Display(mainWindow), True);
- }
- Tk_GeometryRequest(mainWindow, 200, 200);
-
- /*
- * Make command-line arguments available in the Tcl variables "argc"
- * and "argv". Also set the "geometry" variable from the geometry
- * specified on the command line.
- */
-
- args = Tcl_Merge(argc-1, argv+1);
- Tcl_SetVar(interp, "argv", args, TCL_GLOBAL_ONLY);
- ckfree(args);
- sprintf(buf, "%d", argc-1);
- Tcl_SetVar(interp, "argc", buf, TCL_GLOBAL_ONLY);
- Tcl_SetVar(interp, "argv0", (fileName != NULL) ? fileName : argv[0],
- TCL_GLOBAL_ONLY);
- if (geometry != NULL) {
- Tcl_SetVar(interp, "geometry", geometry, TCL_GLOBAL_ONLY);
- }
-
- /*
- * Invoke application-specific initialization.
- */
-
- if (__TclX_AppInit(interp) != TCL_OK) {
- TclX_ErrorExit (interp, 255);
- }
-
- /*
- * Set the geometry of the main window, if requested.
- */
-
- if (geometry != NULL) {
- code = Tcl_VarEval(interp, "wm geometry . ", geometry, (char *) NULL);
- if (code != TCL_OK) {
- fprintf(stderr, "%s\n", interp->result);
- }
- }
-
- /*
- * Invoke the script specified on the command line, if any.
- */
-
- if (fileName != NULL) {
- code = Tcl_VarEval(interp, "source ", fileName, (char *) NULL);
- if (code != TCL_OK) {
- goto error;
- }
- tty = 0;
- } else {
- TclX_EvalRCFile (interp);
-
- /*
- * Commands will come from standard input. Set up a handler
- * to receive those characters and print a prompt if the input
- * device is a terminal.
- */
- tclErrorSignalProc = SignalProc;
- Tk_CreateFileHandler(0, TK_READABLE, StdinProc, (ClientData) 0);
- if (tty) {
- TclX_OutputPrompt (interp, 1);
- }
- }
- tclSignalBackgroundError = Tk_BackgroundError;
-
- fflush(stdout);
- Tcl_DStringInit(&command);
-
- /*
- * Loop infinitely, waiting for commands to execute. When there
- * are no windows left, Tk_MainLoop returns and we exit.
- */
-
- Tk_MainLoop();
-
- /*
- * Don't exit directly, but rather invoke the Tcl "exit" command.
- * This gives the application the opportunity to redefine "exit"
- * to do additional cleanup.
- */
-
- Tcl_GlobalEval(interp, exitCmd);
- exit(1);
-
- error:
- msg = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
- if (msg == NULL) {
- msg = interp->result;
- }
- fprintf(stderr, "%s\n", msg);
- Tcl_GlobalEval(interp, errorExitCmd);
- exit (1);
- return 1; /* Needed only to prevent compiler warnings. */
- }
-
- /*
- *----------------------------------------------------------------------
- *
- * SignalProc --
- *
- * Function called on a signal generating an error to clear the stdin
- * buffer.
- *----------------------------------------------------------------------
- */
-
- static void
- SignalProc (signalNum)
- int signalNum;
- {
- tclGotErrorSignal = 0;
- Tcl_DStringFree (&command);
- gotPartial = 0;
- if (tty) {
- fputc ('\n', stdout);
- TclX_OutputPrompt (interp, !gotPartial);
- }
- }
-
- /*
- *----------------------------------------------------------------------
- *
- * StdinProc --
- *
- * This procedure is invoked by the event dispatcher whenever
- * standard input becomes readable. It grabs the next line of
- * input characters, adds them to a command being assembled, and
- * executes the command if it's complete.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Could be almost arbitrary, depending on the command that's
- * typed.
- *
- *----------------------------------------------------------------------
- */
-
- static void
- StdinProc(clientData, mask)
- ClientData clientData; /* Not used. */
- int mask; /* Not used. */
- {
- #define BUFFER_SIZE 4000
- char input[BUFFER_SIZE+1];
- char *cmd;
- int code, count;
-
- count = read(fileno(stdin), input, BUFFER_SIZE);
- if (count <= 0) {
- if (!gotPartial) {
- if (tty) {
- Tcl_VarEval(interp, "exit", (char *) NULL);
- exit(1);
- } else {
- Tk_DeleteFileHandler(0);
- }
- return;
- } else {
- count = 0;
- }
- }
- cmd = Tcl_DStringAppend(&command, input, count);
- if (count != 0) {
- if ((input[count-1] != '\n') && (input[count-1] != ';')) {
- gotPartial = 1;
- goto exitPoint;
- }
- if (!Tcl_CommandComplete(cmd)) {
- gotPartial = 1;
- goto exitPoint;
- }
- }
- gotPartial = 0;
-
- /*
- * Disable the stdin file handler; otherwise if the command
- * re-enters the event loop we might process commands from
- * stdin before the current command is finished. Among other
- * things, this will trash the text of the command being evaluated.
- */
-
- Tk_CreateFileHandler(0, 0, StdinProc, (ClientData) 0);
- code = Tcl_RecordAndEval(interp, cmd, 0);
- Tk_CreateFileHandler(0, TK_READABLE, StdinProc, (ClientData) 0);
- if (tty)
- TclX_PrintResult (interp, code, cmd);
- Tcl_DStringFree(&command);
-
- exitPoint:
- if (tty) {
- TclX_OutputPrompt (interp, !gotPartial);
- }
- }
-